Games of Daze/Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso/x2ftp/msdos/source/demostuf/ilbm256.pas

Pascal/Delphi Source File | 1994-07-25 | 4.3 KB | 224 lines

UNIT ILBM256;
{
    Converts IFF/ILBM image file in format 320*200 in 256 colours
    a raw image...

  THIS PROGRAM WAS CODED BY BJARKE VIKS0E.
  YOU ARE FREE TO DO WHATEVER YOU WANT WITH THIS PIECE OF CODE.
  E-MAIL ME AT: [e-mail] IN 1994 FOR CHAT AND CODE.
}

INTERFACE

uses
    DEMOINIT;

type
    pBuffer = ^buffertype;
    buffertype = array[1..64000] of byte;

var
    cmap : array[1..256*3] of byte;


procedure LoadPix(buffer : pScreen; filename : string);
procedure ConvertIFF(p : pScreen; v : pBuffer);
procedure SetCMAP;
procedure Copy2Screen(v : pScreen; s : pScreen);
procedure Copy2TweakScreen(v : pScreen; s : pScreen);
procedure MakeTweak(scr1,scr2 : pScreen);
procedure FadeCMAP(faktor : integer);


(*--------------------------------------*)

IMPLEMENTATION


procedure IFFcmap(v : pBuffer; i, clength : longint);
var
    r,g,b : byte;
    j,k : integer;
begin
    k:=1;
    for j:=1 to (clength DIV 3) do begin
        r:=v^[i] div 4; g:=v^[i+1] div 4; b:=v^[i+2] div 4;
        inc(i,3);
        cmap[k]:=r; cmap[k+1]:=g; cmap[k+2]:=b;
        inc(k,3);
    end;
end;


procedure IFFbody(p : pScreen; v : pBuffer; i : longint; VAR done : boolean);
var
    n : word;
    c : shortint;
    fill : byte;
begin
    n:=0; { actual screen offset }
    repeat
        c:=v^[i]; inc(i);
        if (c < 0) then begin
            c:=-c;
            fill:=v^[i]; inc(i);
            FillChar(p^[n],c+1,fill);
            inc(n,c+1);
        end
        else begin
            Move(v^[i],p^[n],c+1);
            inc(i,c+1);
            inc(n,c+1);
        end;
    until (n >= 320*200);

    done:=TRUE;
end;


procedure ConvertIFF(p : pScreen; v : pBuffer);
var
    i : longint;
    done : boolean;
    flength : longint;
    clength : longint;
    chunkname : string[4];
begin
    if (char(v^[1])<>'F') AND (char(v^[2])<>'O') AND (char(v^[3])<>'R') AND (char(v^[4])<>'M') then exit;
    flength:=v^[5] shl 8;
    inc(flength,v^[6]); flength:=flength shl 8;
    inc(flength,v^[7]); flength:=flength shl 8;
    inc(flength,v^[8]);
    if (char(v^[9])<>'P') AND (char(v^[10])<>'B') AND (char(v^[11])<>'M') AND (char(v^[12])<>' ') then exit;

    i:=13;
    done:=FALSE;
    repeat
        chunkname:=concat(char(v^[i]),char(v^[i+1]),char(v^[i+2]),char(v^[i+3]));
        inc(i,4);

        clength:=v^[i] shl 8;
        inc(clength,v^[i+1]); clength:=clength shl 8;
        inc(clength,v^[i+2]); clength:=clength shl 8;
        inc(clength,v^[i+3]);
        if odd(clength) then inc(clength);
        inc(i,4);

        if (chunkname='CMAP') then IFFcmap(v, i,clength);
        if (chunkname='BODY') then IFFbody(p,v, i,done);
        inc(i,clength);
    until (i > flength) OR done;
end;


procedure LoadPix(buffer : pScreen; filename : string);
var
    pFileMem: pBuffer;
    FileHandle : file;
    size : longint;
begin
    Assign(FileHandle, filename);
    Reset(FileHandle, 1);
    size := filesize(FileHandle);
    GetMem(pFileMem, size);
    BlockRead(FileHandle, pFileMem^, size);
    Close(FileHandle);
    ConvertIFF(buffer, pFileMem);
    FreeMem(pFileMem, size);
end;


(*--------------------------------------*)

procedure SetCMAP;
var
    i,j : integer;
begin
    j:=1;
    for i:=0 to 255 do begin
        SetRGB(i,cmap[j],cmap[j+1],cmap[j+2]);
        inc(j,3);
    end;
end;


procedure Copy2Screen(v : pScreen; s : pScreen); assembler;
asm
    push    ds
    lds    si,v
    les    di,s
    cld
    mov    cx,320*200/2
    rep movsw
    pop    ds
end;


procedure Copy2TweakScreen(v : pScreen; s : pScreen);
    procedure CopyPlane(v : pScreen; s : pScreen); assembler;
    asm
        push    ds
        lds    si,v
        les    di,s
        cld
        mov    cx,80*200/2
        rep movsw
        pop    ds
    end;
const
    size = 80*200;
begin
    SetBitplanes(1);
    CopyPlane(@v^[0],s);
    SetBitplanes(2);
    CopyPlane(@v^[size+0],s);
    SetBitplanes(4);
    CopyPlane(@v^[size*2+0],s);
    SetBitplanes(8);
    CopyPlane(@v^[size*3+0],s);
end;


procedure MakeTweak(scr1,scr2 : pScreen);
var
    i,scroffset : integer;
begin
    scroffset:=0;
    for i:=0 to 3 do begin
        SetBitplanes(1 shl i);
        asm
            push    ds
            lds    si,scr1
            les    di,scr2
            add    si,i
            add    di,scroffset
            mov    cx,80*200
            mov    dx,4
            cld
@loop1:    mov    al,[si]
            stosb
            add    si,dx
            loop    @loop1
            pop    ds
        end;
        inc(scroffset,80*200);
    end;
end;

procedure FadeCMAP(faktor : integer);
var
    i,j : integer;
begin
    VBLANK;
    j:=1;
    for i:=0 to 255 do begin
        SetRGB(i,
                longmul(cmap[j],faktor) shr 8,
                longmul(cmap[j+1],faktor) shr 8,
                longmul(cmap[j+2],faktor) shr 8);
        inc(j,3);
    end;
end;

end.